home *** CD-ROM | disk | FTP | other *** search
/ The Ultimate Window Set -…Games & Quality Programs / The Ultimate Window Set - 250 Games & Quality Programs.iso / win / pro125 / napoleon.cdl < prev    next >
Text File  |  1993-09-22  |  7KB  |  337 lines
  1. //⌐ David Jean, 1993
  2. game napoleon is 41 by 24;
  3.  
  4. //    A1 A2 A3 A4 A5 A6 A7 A8
  5. // B1 B2 B3 B4 B5 B6 B7 B8 B9 B0
  6. // 
  7. // D1 D2
  8.  
  9. {--------------------------------------------------------------------------}
  10.  
  11. {****c1 et c2 sont de meme sorte}
  12. predicate SameSuite?(c1, c2 : Card) is
  13.   return (c1 / 13) = (c2 / 13);
  14.  
  15. {****c2 est un de plus que c1}  
  16. predicate FollowSuite?(c1, c2 : Card) is
  17.   return (c1 + 1) = c2;
  18.  
  19. {****c1 et c2 sont du meme Rang}
  20. predicate SameRank?(c1, c2 : Card) is
  21.   return (c1 mod 13) = (c2 mod 13);
  22.  
  23. {****c1 et c2 ont la meme face}
  24. predicate SameCard?(c1, c2 : Card) is
  25.   return (c1 mod DeckSize) = (c2 mod DeckSize);
  26.  
  27. {--------------------------------------------------------------------------}
  28.  
  29. procedure About is
  30. begin
  31.   Clear 'About NapolΘon α Sainte-HΘlΦne';
  32.   write('Rules from : RΘglements officiels des jeux de cartes, Intl. playing card company limited, 1977.\n');
  33.   write('Program : ⌐ David Jean, 1993.\n');
  34. end;
  35.  
  36. procedure RButton is
  37. begin
  38.   Clear 'Right Mouse Button';
  39.   Write('If you click here with the right button, the card will automatically ');
  40.   Write('go to the most appropriate place, looking for a spot in The Foundation first ');
  41.   Write('and then to the Tableau.\n');
  42.   Write('If the card can\'t be played nothing will happen.\n');
  43.   Wait 'About...' About;
  44. end;
  45.  
  46. stack D2;
  47. stack A1;
  48. stack A2;
  49. stack A3;
  50. stack A4;
  51. stack A5;
  52. stack A6;
  53. stack A7;
  54. stack A8;
  55. stack B1;
  56. stack B2;
  57. stack B3;
  58. stack B4;
  59. stack B5;
  60. stack B6;
  61. stack B7;
  62. stack B8;
  63. stack B9;
  64. stack B0;
  65.  
  66. stack D1 is
  67.   X := 2;
  68.   Y := 20;
  69.   Direction := over;
  70.   W := 3;
  71.   H := 4;
  72.   //****************************
  73.   Start is
  74.     begin
  75.     Add Ace+Spade .. King+Diamond;
  76.     Add Ace+Spade .. King+Diamond;
  77.     Turn [1..104] side down;
  78.     Shuffle;
  79.     [0]:=CrossCard;
  80.     end;
  81.   //****************************
  82.   SelectLeftFrom(Spos : Index) is
  83.     begin
  84.     if !<>0 then
  85.       begin
  86.       Turn [!] Side Up;
  87.       Pull 1 To D2;
  88.       end;
  89.     end;
  90.   //****************************
  91.   Help is
  92.     begin
  93.     Clear 'The Stock';
  94.     Write('You can click here to move a card to The Waste Pile.\n');
  95.     Wait 'About...' About;
  96.     end;
  97. end D1;
  98.  
  99. stack D2 is
  100.   X := 7;
  101.   Y := 20;
  102.   Direction := right;
  103.   W := 34;
  104.   H := 4;
  105.   //****************************
  106.   SelectLeftFrom(Spos : Index) is
  107.     if !<>0 then
  108.       Pull 1 To Cursor;
  109.   //****************************
  110.   SelectRightFrom(Spos : Index) is
  111.     begin
  112.     with ST do
  113.       if !<>0 then
  114.         if ((ST!=0) and SameCard?([!],ST[0])) or
  115.            (SameSuite?(ST[ST!],[!]) and FollowSuite?(ST[ST!],[!])) then
  116.           begin
  117.           Pull 1 To ST;
  118.           break procedure;
  119.           end
  120.     for A1, A2, A3, A4, A5, A6, A7, A8;
  121.     with ST do
  122.       if !<>0 then
  123.         if (ST!>0) and 
  124.            (SameSuite?(ST[ST!],[!]) and
  125.             FollowSuite?([!],ST[ST!])) then
  126.           begin
  127.           Pull 1 To ST;
  128.           break procedure;
  129.           end
  130.     for B1, B2, B3, B4, B5, B6, B7, B8, B9, B0;
  131.     with ST do
  132.       if !<>0 then
  133.         if (ST!=0) then
  134.           begin
  135.           Pull 1 To ST;
  136.           break procedure;
  137.           end
  138.     for B1, B2, B3, B4, B5, B6, B7, B8, B9, B0;
  139.     end;
  140.   //****************************
  141.   Help is
  142.     begin
  143.     Clear 'The Waste Pile';
  144.     Write('The topmost card of this pile is available to play on The Tableau or The Foundation.\n\n');
  145.     Write('You can Drag cards from here by using the left mouse button.\n\n');
  146.     Wait 'Right Button...' RButton;
  147.     Wait 'About...' About;
  148.     end;
  149. end D2;
  150.  
  151. {--------------------------------------------------------------------------}
  152.  
  153. stack A1 is
  154.   X := 6;
  155.   Y := 2;
  156.   Direction := over;
  157.   W := 3;
  158.   H := 4;
  159.   //****************************
  160.   Start is
  161.     begin
  162.     [0]:=Ace+Spade;
  163.     Turn [0] Side Shaded;
  164.     end;
  165.   //****************************
  166.   SelectLeftTo(Spos : Index) is
  167.     begin
  168.     if Cursor!=1 then
  169.       if (!=0) and SameCard?([0],Cursor[1]) then
  170.         Pull 1 From Cursor
  171.       else if SameSuite?(Cursor[1],[!]) and
  172.               FollowSuite?([!],Cursor[1]) then
  173.         Pull 1 From Cursor;
  174.     end;
  175.   //****************************
  176.   Help is
  177.     begin
  178.     Clear 'Foundations';
  179.     Write('Plays are made to the Foundations in the same suit and in ascending order.\n\n');
  180.     Write('The goal is to move all 104 cards here.\n\n');
  181.     Write('At the start, this stack is grayed to indicate which card must be played here first.\n');
  182.     Wait 'About...' About;
  183.     end;
  184. end A1;
  185.  
  186. stack A2 from A1 is
  187.   X := 10;
  188.   Y := 2;
  189.   //****************************
  190.   Start is
  191.     begin
  192.     [0]:=Ace+Heart;
  193.     Turn [0] Side Shaded;
  194.     end;
  195. end A2;
  196.  
  197. stack A3 from A1 is
  198.   X := 14;
  199.   Y := 2;
  200.   //****************************
  201.   Start is
  202.     begin
  203.     [0]:=Ace+Club;
  204.     Turn [0] Side Shaded;
  205.     end;
  206. end A3;
  207.  
  208. stack A4 from A1 is
  209.   X := 18;
  210.   Y := 2;
  211.   //****************************
  212.   Start is
  213.     begin
  214.     [0]:=Ace+Diamond;
  215.     Turn [0] Side Shaded;
  216.     end;
  217. end A4;
  218.  
  219. stack A5 from A1 is
  220.   X := 22;
  221.   Y := 2;
  222. end A5;
  223.  
  224. stack A6 from A2 is
  225.   X := 26;
  226.   Y := 2;
  227. end A6;
  228.  
  229. stack A7 from A3 is
  230.   X := 30;
  231.   Y := 2;
  232. end A7;
  233.  
  234. stack A8 from A4 is
  235.   X := 34;
  236.   Y := 2;
  237. end A8;
  238.  
  239. {--------------------------------------------------------------------------}
  240.  
  241. stack B1 is
  242.   X := 2;
  243.   Y := 7;
  244.   Direction := down;
  245.   W := 3;
  246.   H := 12;
  247.   //****************************
  248.   Start is
  249.   begin
  250.     Pull 4 From D1;
  251.     Turn [1..4] Side Up;
  252.     Draw D1;
  253.   end;
  254.   //****************************
  255.   SelectLeftFrom(Spos : Index) is
  256.   begin
  257.     if !>0 then Pull 1 To Cursor;
  258.   end;
  259.   //****************************
  260.   SelectLeftTo(Spos : Index) is
  261.   begin
  262.     if (!=0) then
  263.       Pull 1 From Cursor
  264.     else if SameSuite?(Cursor[1],[!]) and
  265.             FollowSuite?(Cursor[1],[!]) then
  266.       Pull 1 From Cursor;
  267.   end;
  268.   //****************************
  269.   SelectRightFrom from D2;
  270.   //****************************
  271.   Help is
  272.     begin
  273.     Clear 'The Tableau';
  274.     Write('Each card played here must be in descending sequence and of the same suit ');
  275.     Write('to the card on which it is played.\n\n');
  276.     Write('The bottommost card is available to play to The Foundation or to The Tableau.\n');  
  277.     Write('You can Drag cards from here by using the left mouse button.\n\n');
  278.     Write('Any card can be moved in an empty spot.\n');
  279.     Wait 'Right Button...' RButton;
  280.     Wait 'About...' About;
  281.     end;
  282. end B1;
  283.  
  284. stack B2 from B1 is
  285.   X := 6;
  286.   Y := 7;
  287. end B2;
  288.  
  289. stack B3 from B1 is
  290.   X := 10;
  291.   Y := 7;
  292. end B3;
  293.  
  294. stack B4 from B1 is
  295.   X := 14;
  296.   Y := 7;
  297. end B4;
  298.  
  299. stack B5 from B1 is
  300.   X := 18;
  301.   Y := 7;
  302. end B5;
  303.  
  304. stack B6 from B1 is
  305.   X := 22;
  306.   Y := 7;
  307. end B6;
  308.  
  309. stack B7 from B1 is
  310.   X := 26;
  311.   Y := 7;
  312. end B7;
  313.  
  314. stack B8 from B1 is
  315.   X := 30;
  316.   Y := 7;
  317. end B8;
  318.  
  319. stack B9 from B1 is
  320.   X := 34;
  321.   Y := 7;
  322. end B9;
  323.  
  324. stack B0 from B1 is
  325.   X := 38;
  326.   Y := 7;
  327. end B0;
  328.  
  329. {--------------------------------------------------------------------------}
  330.  
  331. predicate Win? is 
  332.   return (A1!=13) and (A2!=13) and (A3!=13) and (A4!=13) and
  333.          (A5!=13) and (A6!=13) and (A7!=13) and (A8!=13);
  334.  
  335. order D1, D2, A1, A2, A3, A4, A5, A6, A7, A8, 
  336.       B1, B2 ,B3, B4, B5, B6, B7, B8, B9, B0.
  337.